home *** CD-ROM | disk | FTP | other *** search
/ Workbench Add-On / Workbench Add-On - Volume 1.iso / Dev / Oberon / source / Obsolete / StdIO.mod < prev   
Encoding:
Text File  |  1995-06-29  |  7.2 KB  |  283 lines
  1. (***************************************************************************
  2.  
  3.      $RCSfile: StdIO.mod $
  4.   Description: Simple formatted I/O using the standard input and output
  5.                handles.
  6.  
  7.    Created by: fjc (Frank Copeland)
  8.     $Revision: 1.15 $
  9.       $Author: fjc $
  10.         $Date: 1995/06/29 19:06:56 $
  11.  
  12.   Copyright © 1994, Frank Copeland.
  13.   This file is part of the Oberon-A Library.
  14.   See Oberon-A.doc for conditions of use and distribution.
  15.  
  16. ***************************************************************************)
  17.  
  18. <* STANDARD- *>
  19.  
  20. MODULE StdIO;
  21.  
  22. IMPORT SYS := SYSTEM, e := Exec, d := Dos, du := DosUtil, Reals, WbConsole;
  23.  
  24. CONST
  25.   maxD = 9;
  26.  
  27. (*------------------------------------*)
  28. PROCEDURE Write* (ch : CHAR);
  29.  
  30. BEGIN (* Write *)
  31.   du.HaltIfBreak ({d.ctrlC});
  32.   SYS.PUTREG (0, d.Write (d.Output(), ch, 1))
  33. END Write;
  34.  
  35. (*------------------------------------*)
  36. PROCEDURE WriteLn*;
  37.  
  38. BEGIN (* WriteLn *)
  39.   Write (0AX)
  40. END WriteLn;
  41.  
  42. (*------------------------------------*)
  43. PROCEDURE WriteStr* (s : ARRAY OF CHAR);
  44.  
  45. <*$CopyArrays-*>
  46. BEGIN (* WriteStr *)
  47.   du.HaltIfBreak ({d.ctrlC});
  48.   SYS.PUTREG (0, d.Write (d.Output (), s, SYS.STRLEN (s)))
  49. END WriteStr;
  50.  
  51. (*------------------------------------*)
  52. PROCEDURE* PutCh ();
  53.  
  54. <*$EntryExitCode-*>
  55. BEGIN (* PutCh *)
  56.   SYS.INLINE (16C0H,   (* MOVE.B D0,(A3)+ *)
  57.               4E75H)   (* RTS             *)
  58. END PutCh;
  59.  
  60. (*------------------------------------*)
  61. PROCEDURE WriteInt* (i : LONGINT);
  62.  
  63.   VAR
  64.     str : ARRAY 256 OF CHAR;
  65.  
  66. BEGIN (* WriteInt *)
  67.   e.OldRawDoFmtL ("%ld", i, PutCh, SYS.ADR (str));
  68.   WriteStr (str)
  69. END WriteInt;
  70.  
  71. (*------------------------------------*)
  72. PROCEDURE WriteHex* (i : LONGINT);
  73.  
  74.   VAR
  75.     str : ARRAY 256 OF CHAR;
  76.  
  77. BEGIN (* WriteHex *)
  78.   e.OldRawDoFmtL ("%lx", i, PutCh, SYS.ADR (str));
  79.   WriteStr (str)
  80. END WriteHex;
  81.  
  82. (*
  83.  * The following WriteReal* and WriteLongReal* procedures have been pinched
  84.  * from Module Texts and have been somewhat modified from the original code
  85.  * described in "Project Oberon".
  86.  *)
  87.  
  88. (*------------------------------------*)
  89. PROCEDURE WriteReal * ( x : REAL; n : INTEGER );
  90.  
  91.   VAR e : INTEGER; x0 : REAL; d : ARRAY maxD OF CHAR;
  92.  
  93. BEGIN (* WriteReal *)
  94.   e := Reals.Expo (x);
  95.   IF e = 0 THEN
  96.     WriteStr ("0");
  97.     REPEAT Write (" "); DEC (n) UNTIL n <= 3
  98.   ELSIF e = 255 THEN
  99.     WriteStr ("NaN");
  100.     WHILE n > 4 DO Write (" "); DEC (n) END
  101.   ELSE
  102.     IF n <= 9 THEN n := 3 ELSE DEC (n, 6) END;
  103.     REPEAT Write (" "); DEC (n) UNTIL n <= 8;
  104.     (* there are 2 < n <= 8 digits to be written *)
  105.     IF x < 0.0 THEN Write ("-"); x := -x ELSE Write (" ") END;
  106.     e := (e - 127) * 77 DIV 256;
  107.     IF e >= 0 THEN x := x / Reals.Ten (e) ELSE x := Reals.Ten (-e) * x END;
  108.     IF x >= 10.0 THEN x := 0.1 * x; INC (e) END;
  109.     x0 := Reals.Ten (n - 1); x := x0 * x + 0.5;
  110.     IF x >= 10.0 * x0 THEN x := x * 0.1; INC (e) END;
  111.     Reals.Convert (x, n, d);
  112.     DEC (n); Write (d [n]); Write (".");
  113.     REPEAT DEC (n); Write (d [n]) UNTIL n = 0;
  114.     Write ("E");
  115.     IF e < 0 THEN Write ("-"); e := -e ELSE Write ("+") END;
  116.     Write (CHR (e DIV 10 + 30H)); Write (CHR (e MOD 10 + 30H))
  117.   END
  118. END WriteReal;
  119.  
  120. (*------------------------------------*)
  121. PROCEDURE WriteRealFix * ( x : REAL; n, k : INTEGER );
  122.  
  123.   VAR e, i : INTEGER; sign : CHAR; x0 : REAL; d : ARRAY maxD OF CHAR;
  124.  
  125.   (*------------------------------------*)
  126.   PROCEDURE seq ( ch : CHAR; n : LONGINT );
  127.  
  128.   BEGIN (* seq *)
  129.     WHILE n > 0 DO Write (ch); DEC (n) END
  130.   END seq;
  131.  
  132.   (*------------------------------------*)
  133.   PROCEDURE dig (n : INTEGER);
  134.  
  135.   BEGIN (* dig *)
  136.     WHILE n > 0 DO
  137.       DEC (i); Write (d [i]); DEC (n)
  138.     END;
  139.   END dig;
  140.  
  141. BEGIN (* WriteRealFix *)
  142.   e := Reals.Expo (x);
  143.   IF k < 0 THEN k := 0 END;
  144.   IF e = 0 THEN
  145.     seq (" ", n - k - 2); Write ("0"); seq (" ", k + 1)
  146.   ELSIF e = 255 THEN
  147.     WriteStr ("NaN"); seq (" ", n - 4)
  148.   ELSE
  149.     e := (e - 127) * 77 DIV 256;
  150.     IF x < 0.0 THEN sign := "-"; x := -x ELSE sign := " " END;
  151.     IF e >= 0 THEN (* x >= 1.0, 77/256 = log 2 *) x := x / Reals.Ten (e)
  152.     ELSE (* x < 1.0 *) x := Reals.Ten (-e) * x
  153.     END;
  154.     IF x >= 10.0 THEN x := 0.1 * x; INC (e) END;
  155.     (* 1 <= x < 10 *)
  156.     IF k + e >= maxD - 1 THEN k := maxD - 1 - e
  157.     ELSIF k + e < 0 THEN k := -e; x := 0.0
  158.     END;
  159.     x0 := Reals.Ten (k + e); x := x0 * x + 0.5;
  160.     IF x >= 10.0 * x0 THEN INC (e) END;
  161.     (* e = no. of digits before decimal point *)
  162.     INC (e); i := k + e; Reals.Convert (x, i, d);
  163.     IF e > 0 THEN
  164.       seq (" ", n - e - k - 2); Write (sign); dig (e); Write (".");
  165.       dig (k)
  166.     ELSE
  167.       seq (" ", n - k - 3); Write (sign); Write ("0"); Write (".");
  168.       seq ("0", -e); dig (k + e)
  169.     END
  170.   END
  171. END WriteRealFix;
  172.  
  173. (*------------------------------------*)
  174. PROCEDURE WriteRealHex * ( x : REAL );
  175.  
  176.   VAR d : ARRAY 9 OF CHAR;
  177.  
  178. BEGIN (* WriteRealHex *)
  179.   Reals.ConvertH (x, d); d [8] := 0X; WriteStr (d)
  180. END WriteRealHex;
  181.  
  182. (*------------------------------------*)
  183. PROCEDURE WriteLongReal * ( x : LONGREAL; n : INTEGER );
  184.  
  185. BEGIN (* WriteLongReal *)
  186.   (*
  187.    * In this implementation, LONGREAL and REAL types are the same, so this
  188.    * procedure is implemented as a call to WriteReal ().
  189.    *)
  190.   WriteReal (SHORT (x), n)
  191. END WriteLongReal;
  192.  
  193. (*------------------------------------*)
  194. PROCEDURE WriteLongRealHex * ( x : LONGREAL );
  195.  
  196. BEGIN (* WriteLongRealHex *)
  197.   (*
  198.    * In this implementation, LONGREAL and REAL types are the same, so this
  199.    * procedure is implemented as a call to WriteRealHex ().
  200.    *)
  201.   WriteRealHex (SHORT (x))
  202. END WriteLongRealHex;
  203.  
  204. (*------------------------------------*)
  205. PROCEDURE WriteF* (
  206.   fs : ARRAY OF CHAR; VAR f : ARRAY OF SYS.LONGWORD);
  207.  
  208.   VAR
  209.     str : ARRAY 256 OF CHAR;
  210.  
  211. <*$CopyArrays-*>
  212. BEGIN (* WriteF *)
  213.   e.OldRawDoFmtL (fs, f, PutCh, SYS.ADR (str));
  214.   WriteStr (str)
  215. END WriteF;
  216.  
  217. (*------------------------------------*)
  218. PROCEDURE WriteF1*
  219.   ( fs     : ARRAY OF CHAR;
  220.     param1 : SYS.LONGWORD);
  221.  
  222.   VAR str : ARRAY 256 OF CHAR;
  223.  
  224. <*$CopyArrays-*>
  225. BEGIN (* WriteF1 *)
  226.   e.OldRawDoFmtL (fs, param1, PutCh, SYS.ADR (str));
  227.   WriteStr (str)
  228. END WriteF1;
  229.  
  230. (*------------------------------------*)
  231. PROCEDURE WriteF2* (
  232.   fs : ARRAY OF CHAR; param1, param2 : SYS.LONGWORD);
  233.  
  234.   VAR str : ARRAY 256 OF CHAR; t : SYS.LONGWORD;
  235.  
  236. <*$CopyArrays-*>
  237. BEGIN (* WriteF2 *)
  238.   t := param1; param1 := param2; param2 := t;
  239.   e.OldRawDoFmtL (fs, param2, PutCh, SYS.ADR (str));
  240.   WriteStr (str)
  241. END WriteF2;
  242.  
  243. (*------------------------------------*)
  244. PROCEDURE WriteF3* (
  245.   fs : ARRAY OF CHAR; param1, param2, param3 : SYS.LONGWORD);
  246.  
  247.   VAR str : ARRAY 256 OF CHAR; t : SYS.LONGWORD;
  248.  
  249. <*$CopyArrays-*>
  250. BEGIN (* WriteF3 *)
  251.   t := param1; param1 := param3; param3 := t;
  252.   e.OldRawDoFmtL (fs, param3, PutCh, SYS.ADR (str));
  253.   WriteStr (str)
  254. END WriteF3;
  255.  
  256. (*------------------------------------*)
  257. PROCEDURE Read* (VAR ch : CHAR);
  258.  
  259. BEGIN (* Read *)
  260.   du.HaltIfBreak ({d.ctrlC});
  261.   IF d.Read (d.Input (), ch, 1) < 1 THEN ch := 0X END;
  262. END Read;
  263.  
  264. (*------------------------------------*)
  265. PROCEDURE ReadStr* (VAR str : ARRAY OF CHAR);
  266.  
  267.   VAR ch : CHAR; index, limit : INTEGER;
  268.  
  269. BEGIN (* ReadStr *)
  270.   (* Skip white space *)
  271.   REPEAT Read (ch) UNTIL (ch # " ") & (ch # 09X);
  272.   (* Read until control char *)
  273.   index := 0; limit := SHORT (LEN (str));
  274.   WHILE (ch >= " ") & (index < limit) DO
  275.     str [index] := ch; INC (index); Read (ch);
  276.   END; (* WHILE *)
  277.   str [index] := 0X;
  278.   (* Skip rest of line if any *)
  279.   WHILE ch >= " " DO Read (ch) END;
  280. END ReadStr;
  281.  
  282. END StdIO.
  283.